home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / ODE / obj_string < prev    next >
Encoding:
Text File  |  1991-10-24  |  2.4 KB  |  150 lines
  1. \ Define basic text STRING class.
  2. \
  3. \ Author: Phil Burk
  4. \ Copyright 1986 Delta Research
  5. \
  6. \ MOD: PLB 12/15/87 Fix stack diagram in APPEND:
  7. \ MOD: PLB 9/13/88 Remove MRESET
  8.  
  9. ANEW TASK-OBJ_STRING
  10.  
  11. METHOD TYPE:
  12. METHOD READLINE:
  13. METHOD WRITELINE:
  14. .NEED LOAD:    METHOD LOAD:    .THEN
  15. METHOD COPYSUB:
  16. METHOD APPEND:
  17. METHOD COUNT:
  18. METHOD TOUPPER:
  19. METHOD TOLOWER:
  20. METHOD SMART.WORD:
  21. METHOD WORD:
  22. METHOD STRIP:
  23. METHOD ?NOW.AT:
  24. METHOD GOTO:
  25.  
  26. :CLASS OB.STRING <SUPER OB.ELMNTS
  27.  
  28. :M INIT: ( -- , set to byte width )
  29.     init: super
  30.     1 set.width: self
  31. ;M
  32.  
  33. :M NEW: ( #chars -- allocate storage )
  34.     1 new: super
  35. ;M
  36.  
  37. :M ?NOW.AT: ( -- e# , current element number )
  38.     iv-current
  39. ;M
  40.  
  41. :M GOTO: ( e# -- , set current element number )
  42.     dup 0 ed2i: self range: self
  43.     iv=> iv-current
  44. ;M
  45.  
  46. :M COUNT: ( -- addr count , return address and count of characters )
  47.     data.addr: self many: self
  48. ;M
  49.  
  50. :M TYPE: ( -- , Type contents. )
  51.     count: self type
  52. ;M
  53.  
  54. :M TOUPPER: ( -- , Convert string to upper case )
  55.     many: self 0
  56.     DO i at: self toupper i to: self
  57.     LOOP
  58. ;M
  59.  
  60. :M TOLOWER: ( -- , Convert string to lower case )
  61.     many: self 0
  62.     DO i at: self tolower i to: self
  63.     LOOP
  64. ;M
  65.  
  66. :M LOAD: ( addr count -- , load with characters )
  67.     dup limit: self >
  68.     IF " LOAD: OB.STRING" " Not enough room"
  69.         er_fatal ob.report.error
  70.     THEN
  71.     clear: self
  72.     0 DO
  73.         dup c@ add: self
  74.         1+
  75.     LOOP drop
  76. ;M
  77.  
  78. :M READLINE: ( fileptr -- #chars | -1 , Read using pad )
  79.     clear: self
  80.     BEGIN
  81.         dup fkey
  82.         dup EOL = NOT
  83.         over EOF = NOT AND
  84.     WHILE
  85.         add: self
  86.     REPEAT
  87.     nip  EOF =
  88.     IF -1
  89.     ELSE many: self
  90.     THEN
  91.     reset: self
  92. ;M
  93.  
  94. :M WRITELINE: ( fileptr -- , write characters to file )
  95.     dup count: self fwrite 0<
  96.     IF " WRITELINE: OB.STRING" " Write failed!"
  97.         er_fatal ob.report.error
  98.     THEN
  99.     $ 0A femit   ( line terminator )
  100. ;M
  101.  
  102. :M COPY: ( elmobj -- , copy elements )
  103.     clear: self
  104.     dup many: [] 0
  105.     DO i over get: []
  106.         add: self
  107.     LOOP drop
  108. ;M
  109.  
  110. :M APPEND: ( addr count -- , Add string )
  111.     0
  112.     DO  dup c@ add: self 1+
  113.     LOOP  drop
  114. ;M
  115.  
  116. :M WORD: ( char -- addr , test characters until match )
  117.     manyleft: self 0
  118.     DO
  119.         next: self dup 2 pick83 =
  120.         IF drop leave
  121.         ELSE pad 1+ i + c!
  122.             i 1+ pad c!
  123.         THEN
  124.     LOOP
  125.     drop pad
  126. ;M
  127.  
  128. :M SMART.WORD: ( cfa -- addr , test characters against cfa until true )
  129.     manyleft: self 0
  130.     DO
  131.         next: self dup 2 pick83 execute
  132.         IF drop leave
  133.         ELSE pad 1+ i + c!
  134.             i 1+ pad c!
  135.         THEN
  136.     LOOP
  137.     drop pad
  138. ;M
  139.  
  140. :M STRIP: ( char -- , strip character out of string )
  141.     BEGIN
  142.         dup indexof: self
  143.     WHILE
  144.         remove: self
  145.     REPEAT
  146.     drop
  147. ;M
  148.  
  149. ;CLASS
  150.